home *** CD-ROM | disk | FTP | other *** search
/ Enter 2004 January / enter-2004-01.iso / files / maxima-5.9.0.exe / {app} / share / maxima / 5.9.0 / src / rat3b.lisp < prev    next >
Encoding:
Text File  |  2003-02-09  |  8.3 KB  |  251 lines
  1. ;;; -*-  Mode: Lisp; Package: Maxima; Syntax: Common-Lisp; Base: 10 -*- ;;;;
  2. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  3. ;;;     The data in this file contains enhancments.                    ;;;;;
  4. ;;;                                                                    ;;;;;
  5. ;;;  Copyright (c) 1984,1987 by William Schelter,University of Texas   ;;;;;
  6. ;;;     All rights reserved                                            ;;;;;
  7. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  8. ;;;     (c) Copyright 1980 Massachusetts Institute of Technology         ;;;
  9. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  10.  
  11. (in-package "MAXIMA")
  12. (macsyma-module rat3b)
  13.  
  14. ;;    THIS IS THE NEW RATIONAL FUNCTION PACKAGE PART 2.
  15. ;;    IT INCLUDES RATIONAL FUNCTIONS ONLY.
  16.  
  17. (DECLARE-TOP(GENPREFIX A_2)
  18.      (special $ALGEBRAIC $RATFAC $KEEPFLOAT $FLOAT))
  19.  
  20. (LOAD-MACSYMA-MACROS RATMAC)
  21.  
  22. (DEFMVAR $RATWTLVL NIL) 
  23. (DEFMVAR $RATALGDENOM T)  ;If T then denominator is rationalized.
  24.  
  25. (DEFUN RALGP (R) (OR (PALGP (CAR R)) (PALGP (CDR R))))
  26.  
  27. (DEFUN PALGP (POLY)
  28.   (COND ((PCOEFP POLY) NIL)
  29.     ((ALG POLY) T)
  30.     (T (DO ((P (CDR POLY) (CDDR P))) ((NULL P))
  31.          (AND (PALGP (CADR P)) (RETURN T))))))
  32.  
  33.  
  34.  
  35.  
  36. (DEFUN RATDX (E *X*)
  37.  (declare (special *x*))
  38.  (PROG (VARLIST FLAG V* GENVAR *A A TRUNCLIST)
  39.        (DECLARE (SPECIAL V* *A FLAG TRUNCLIST))
  40.        (AND (MEMQ 'TRUNC (CAR E)) (SETQ TRUNCLIST (CADDDR (CDAR E))))
  41.        (COND ((NOT (EQ (CAAR E) (QUOTE MRAT))) (SETQ E (RATF E))))
  42.        (SETQ VARLIST (CADDAR E))
  43.        (SETQ GENVAR (CAR (CDDDAR E)))
  44.        ;; Next cond could be flushed if genvar would shrink with varlist
  45.        (COND ((> (LENGTH GENVAR) (LENGTH VARLIST))
  46.           ;; Presumably this produces a copy of GENVAR which has the
  47.           ;; same length as VARLIST.  Why not rplacd?
  48.           (SETQ GENVAR (MAPCAR #'(LAMBDA (A B) A ;Ignored
  49.                          B)
  50.                    VARLIST GENVAR))))
  51.        (SETQ *X* (FULLRATSIMP *X*))
  52.        (NEWVAR *X*) 
  53.        (SETQ A (MAPCAN #'(LAMBDA (Z)
  54.                  (PROG (FF)
  55.                        (NEWVAR 
  56.                     (SETQ FF (FULLRATSIMP (SDIFF Z *X*))))
  57.                        (ORDERPOINTER VARLIST)
  58.                        (RETURN (LIST Z FF)))) VARLIST))
  59.        (SETQ *A (CONS NIL A))
  60.        (MAPC #'(LAMBDA(Z B)
  61.               (COND ((NULL (OLD-GET *A Z))(PUTPROP B (RZERO) 'DIFF))
  62.                 ((AND(PUTPROP B(CDR (RATF (OLD-GET *A Z))) 'DIFF)
  63.                  (ALIKE1 Z *X*))
  64.                  (SETQ V*  B))
  65.                 (T (SETQ FLAG T)))) VARLIST GENVAR)
  66.        (COND ((AND (SIGNP N (CDR (OLD-GET TRUNCLIST V*)))
  67.            (CAR (OLD-GET TRUNCLIST V*))) (RETURN 0)))         
  68.        (AND TRUNCLIST
  69.         (RETURN (CONS (LIST 'MRAT 'SIMP VARLIST GENVAR TRUNCLIST 'TRUNC)
  70.               (COND (FLAG (PSDP (CDR E)))
  71.                 (T (PSDERIVATIVE (CDR E) V*))))))
  72.        (RETURN (CONS (LIST 'MRAT 'SIMP VARLIST GENVAR)
  73.              (COND (FLAG (RATDX1 (CADR E) (CDDR E)))
  74.                (T (RATDERIVATIVE (CDR E) V*)))))))
  75.  
  76. (DEFUN RATDX1 (U V)
  77.        (RATQUOTIENT (RATDIF (RATTIMES (CONS V 1) (RATDP U) T)
  78.                 (RATTIMES (CONS U 1) (RATDP V) T))
  79.             (CONS (PEXPT V 2) 1)))
  80.  
  81. (DEFUN RATDP (P) (COND ((PCOEFP P) (RZERO))
  82.                ((RZEROP (GET (CAR P) 'DIFF))
  83.             (RATDP1 (CONS (LIST (CAR P) 'FOO 1) 1) (CDR P)))
  84.                (T (RATDP2 (CONS (LIST (CAR P) 'FOO 1) 1)
  85.                   (GET (CAR P) 'DIFF)
  86.                   (CDR P)))))
  87.  
  88. (DEFUN RATDP1 (X V)
  89.   (COND ((NULL V) (RZERO))
  90.     ((EQN (CAR V) 0) (RATDP (CADR V)))
  91.     (T (RATPLUS (RATTIMES (SUBST (CAR V) 'FOO X) (RATDP (CADR V)) T)
  92.             (RATDP1 X (CDDR V))))))
  93.  
  94. (DEFUN RATDP2 (X DX V)
  95.        (COND ((NULL V) (RZERO))
  96.          ((EQN (CAR V) 0) (RATDP (CADR V)))
  97.          ((EQN (CAR V) 1)
  98.           (RATPLUS (RATDP2 X DX (CDDR V))
  99.                (RATPLUS (RATTIMES DX (CONS (CADR V) 1) T)
  100.                 (RATTIMES (SUBST 1 'FOO X)
  101.                       (RATDP (CADR V)) T))))
  102.          (T (RATPLUS (RATDP2 X DX (CDDR V))
  103.              (RATPLUS (RATTIMES DX
  104.                         (RATTIMES (SUBST (SUB1 (CAR V))
  105.                                  'FOO
  106.                                  X)
  107.                               (CONS (PTIMES (CAR V)
  108.                                     (CADR V))
  109.                                 1)
  110.                               T)
  111.                         T)
  112.                   (RATTIMES (RATDP (CADR V))
  113.                         (SUBST (CAR V) (QUOTE FOO) X)
  114.                         T))))))
  115.  
  116. (DEFMFUN RATDERIVATIVE (RAT  VAR)
  117.  (LET ((NUM (CAR RAT))
  118.     (DENOM (CDR RAT)))
  119.    (COND ((EQN 1 DENOM) (CONS (PDERIVATIVE NUM VAR) 1))
  120.      (T (SETQ DENOM (PGCDCOFACTS DENOM (PDERIVATIVE DENOM VAR)))
  121.         (SETQ NUM (RATREDUCE (PDIFFERENCE (PTIMES (CADR DENOM)
  122.                               (PDERIVATIVE NUM VAR))
  123.                           (PTIMES NUM (CADDR DENOM)))
  124.                  ;RATREDUCE ONLY NEEDS TO BE DONE WITH CONTENT OF GCD WRT VAR.
  125.                   (CAR DENOM)))
  126.         (COND ((PZEROP (CAR NUM)) NUM)
  127.           (T (RPLACD NUM (PTIMES (CDR NUM)
  128.                      (PEXPT (CADR DENOM) 2)))))))))
  129.  
  130. ;; (DEFMFUN RATABS (Y)
  131. ;;  (COND ((PMINUSP (CAR Y)) (CONS (PMINUS (CAR Y)) (CDR Y)))
  132. ;;     (T Y)))
  133.  
  134.  
  135. (DEFMFUN RATDIF (X Y) (RATPLUS X (RATMINUS Y))) 
  136.  
  137. (DEFMFUN RATFACT (X FN)
  138.   (declare (object fn))
  139.   (COND ((AND $KEEPFLOAT (OR (PFLOATP (CAR X)) (PFLOATP (CDR X)))
  140.           (SETQ FN 'FLOATFACT) NIL))
  141.     ((NOT (EQUAL (CDR X) 1))
  142.      (NCONC (FUNCALL FN (CAR X)) (FIXMULT (FUNCALL FN (CDR X)) -1)))
  143.     (T (FUNCALL FN (CAR X)))))
  144.      
  145. (DEFUN FLOATFACT (P)
  146.   (LET (((CONT PRIMP) (PTERMCONT P)))
  147.        (SETQ CONT (MONOM->FACL CONT))
  148.        (COND ((EQUAL PRIMP 1) CONT)
  149.          (T (APPEND CONT (LIST PRIMP 1))))))
  150.  
  151. ;; (DEFUN RATGCM (X Y)
  152. ;;   (CONS (PGCD (CAR X) (CAR Y)) (PLCM (CDR X) (CDR Y))))
  153.  
  154. (DEFUN RATINVERT (Y)
  155.   (RATALGDENOM
  156.    (COND ((PZEROP (CAR Y)) (ERRRJF "QUOTIENT by ZERO"))
  157.      ((AND MODULUS (PCOEFP (CAR Y)))
  158.       (CONS (PCTIMES (CRECIP (CAR Y)) (CDR Y)) 1))
  159.      ((AND $KEEPFLOAT (FLOATP (CAR Y)))
  160.       (CONS (PCTIMES (*QUO 1.0 (CAR Y)) (CDR Y)) 1))
  161.      ((PMINUSP (CAR Y)) (CONS (PMINUS (CDR Y)) (PMINUS (CAR Y))))
  162.      (T (CONS (CDR Y) (CAR Y))))))
  163.  
  164. (DEFMFUN RATMINUS (X) (CONS (PMINUS (CAR X)) (CDR X)))
  165.      
  166. (DEFUN RATALGDENOM (X)
  167.        (COND ((NOT $RATALGDENOM) X)
  168.          ((PCOEFP (CDR X)) X)
  169.          ((AND (ALG (CDR X))
  170.            (LET ((ERRRJFFLAG T))
  171.              (CATCH 'RATERR
  172.                  (RATTIMES (CONS (CAR X) 1)
  173.                        (RAINV (CDR X)) T)))))
  174.          (T X)))
  175.  
  176. (DEFMFUN RATREDUCE (X Y &AUX B)
  177.   (COND ((PZEROP Y) (ERRRJF "QUOTIENT by ZERO"))
  178.     ((PZEROP X) (RZERO))
  179.     ((EQN Y 1) (CONS X 1))
  180.     ((AND $KEEPFLOAT (PCOEFP Y) (OR $FLOAT (FLOATP Y) (PFLOATP X)))
  181.      (CONS (PCTIMES (QUOTIENT 1.0 Y) X) 1))
  182.     (T (SETQ B (PGCDCOFACTS X Y))
  183.        (SETQ B (RATALGDENOM (RPLACD (CDR B) (CADDR B))))
  184.        (COND ((AND MODULUS (PCOEFP (CDR B)))
  185.           (CONS (PCTIMES (CRECIP (CDR B)) (CAR B)) 1))
  186.          ((PMINUSP (CDR B))
  187.           (CONS (PMINUS (CAR B)) (PMINUS (CDR B))))
  188.          (T B)))))
  189.  
  190.  
  191. (DEFUN PTIMES* (P Q)
  192.        (COND ($RATWTLVL (WTPTIMES P Q 0))
  193.          (T (PTIMES P Q))))
  194.  
  195. (DEFMFUN RATTIMES (X Y GCDSW)
  196.   (COND ($RATFAC (FACRTIMES X Y GCDSW))
  197.     ((AND $ALGEBRAIC GCDSW (RALGP X) (RALGP Y))
  198.      (let ((w  (RATTIMES X Y NIL)))
  199.        (RATREDUCE (CAR w) (CDR w))))
  200.     ((EQN 1 (CDR X))
  201.      (COND ((EQN 1 (CDR Y)) (CONS (PTIMES* (CAR X) (CAR Y)) 1))
  202.            (T (COND (GCDSW (RATTIMES (RATREDUCE (CAR X) (CDR Y))
  203.                      (CONS (CAR Y) 1) NIL))
  204.             (T (CONS (PTIMES* (CAR X) (CAR Y)) (CDR Y)))))))
  205.     ((EQN 1 (CDR Y)) (RATTIMES Y X GCDSW))
  206.     (T (COND (GCDSW (RATTIMES (RATREDUCE (CAR X) (CDR Y))
  207.                   (RATREDUCE (CAR Y) (CDR X)) NIL))
  208.          (T (CONS (PTIMES* (CAR X) (CAR Y))
  209.               (PTIMES* (CDR X) (CDR Y))))))))
  210.       
  211. (DEFMFUN RATEXPT (X N)
  212.   (COND ((EQUAL N 0) '(1 . 1))
  213.     ((EQUAL N 1) X)
  214.     ((MINUSP N) (RATINVERT (RATEXPT X (MINUS N))))
  215.     ($RATWTLVL (RATREDUCE (WTPEXPT (CAR X) N) (WTPEXPT (CDR X) N)))
  216.     ($ALGEBRAIC (RATREDUCE (PEXPT (CAR X) N) (PEXPT (CDR X) N)))
  217.     (T (CONS (PEXPT (CAR X) N) (PEXPT (CDR X) N)))))
  218.  
  219. (DEFMFUN RATPLUS (X Y &AUX Q N)
  220.   (COND ($RATFAC (FACRPLUS X Y))
  221.     ($RATWTLVL
  222.      (RATREDUCE
  223.       (PPLUS (WTPTIMES (CAR X) (CDR Y) 0)
  224.          (WTPTIMES (CAR Y) (CDR X) 0))
  225.       (WTPTIMES (CDR X) (CDR Y) 0)))
  226.     ((AND $ALGEBRAIC (RALGP X) (RALGP Y))
  227.      (RATREDUCE
  228.       (PPLUS (PTIMESCHK (CAR X) (CDR Y))
  229.          (PTIMESCHK (CAR Y) (CDR X)))
  230.       (PTIMESCHK (CDR X) (CDR Y))))
  231.     ((EQN 1 (CDR X))
  232.      (COND ((EQN 0 (CAR X)) Y)
  233.            ((EQN 1 (CDR Y)) (CONS (PPLUS (CAR X) (CAR Y)) 1))
  234.            (T (CONS (PPLUS (PTIMES (CAR X) (CDR Y)) (CAR Y)) (CDR Y)))))
  235.     ((EQN 1 (CDR Y))
  236.      (COND ((EQN 0 (CAR Y)) X)
  237.            (T (CONS (PPLUS (PTIMES (CAR Y) (CDR X)) (CAR X)) (CDR X)))))
  238.     (T (SETQ Q (PGCDCOFACTS (CDR X) (CDR Y)))
  239.        (SETQ N (PPLUS (PTIMES (CAR X)(CADDR Q))
  240.               (PTIMES (CAR Y)(CADR Q))))
  241.        (COND ((PZEROP N) (RZERO))
  242.          ((EQN 1 (CAR Q)) (CONS N (PTIMES (CDR X) (CDR Y))))
  243.          (T (SETQ N (RATREDUCE N (CAR Q)))
  244.             (CONS (CAR N) (PTIMES (CDR N)
  245.                       (PTIMES (CADR Q) (CADDR Q)))))))))
  246.  
  247. (DEFMFUN RATQUOTIENT (X Y) (RATTIMES X (RATINVERT Y) T)) 
  248.  
  249. ;;    THIS IS THE END OF THE NEW RATIONAL FUNCTION PACKAGE PART 2.
  250. ;;    IT INCLUDES RATIONAL FUNCTIONS ONLY.
  251.